home *** CD-ROM | disk | FTP | other *** search
/ The Atari Compendium / The Atari Compendium (Toad Computers) (1994).iso / files / prgtools / langs / pcl-src.zoo / user-instances.lsp < prev    next >
Encoding:
Text File  |  1992-09-03  |  27.9 KB  |  685 lines
  1. ;;;-*-Mode:LISP; Package: PCL; Base:10; Syntax:Common-lisp; -*-
  2.  
  3. ;;;
  4. ;;; *************************************************************************
  5. ;;;
  6. ;;;   File: user-instances.lisp.
  7. ;;;
  8. ;;;     by Trent E. Lange, Effective Date 06-02-92
  9. ;;;
  10. ;;;
  11. ;;;  This file contains a metaclass (User-Vector-Class) whose instances
  12. ;;; are stored as simple-vectors, saving space over PCL's standard instance
  13. ;;; representations of PCL at the cost of some class redefinition flexibiliity.
  14. ;;;
  15. ;;; Permission is granted to any individual or institution to use, copy,
  16. ;;; modify and distribute this document.
  17. ;;;
  18. ;;; Suggestions, bugs, criticism and questions to lange@cs.ucla.edu
  19. ;;; *************************************************************************
  20. ;;;
  21.  
  22. (in-package 'pcl)
  23.  
  24. ;;;   This file builds on the PCL-USER-INSTANCES feature of July 92 PCL
  25. ;;; to define the USER-VECTOR-CLASS metaclass whose instances are simple
  26. ;;; vectors.  The first element of the instance vector is the instance's
  27. ;;; class wrapper (providing internal PCL information about the instance's
  28. ;;; class).  The remaining elements of the instance vector are the instance's
  29. ;;; slots themselves.
  30. ;;;
  31. ;;;   The space overhead of user-vector-instances is only two vector cells
  32. ;;; (one for the vector, one for the wrapper).  This is contrast to standard
  33. ;;; PCL instances, which have a total overhead of four cells.  (Standard
  34. ;;; instances in PCL are represented as instances of structure STD-INSTANCE
  35. ;;; having two slots, one for the wrapper and one holding a simple-vector
  36. ;;; which is the instance's slots).  This two-cell space savings per instance
  37. ;;; comes at the cost of losing some class redefinition flexibility, since
  38. ;;; simple-vectors cannot have their sizes changed dynamically.
  39. ;;; All current instances of user-instance-vectors therefore become
  40. ;;; permanently obsolete if the classes' instance slots change.
  41. ;;;
  42. ;;;   This code requires July 92 PCL or later compiled with the
  43. ;;; PCL-USER-INSTANCES feature turned on (see PCL's low.lisp file).
  44. ;;;
  45.  
  46. #-pcl-user-instances
  47. (eval-when (compile load eval)
  48. (error "Cannot use user-instances, since PCL was compiled without
  49.         PCL-USER-INSTANCES on the *features* list (see pcl file low.lisp.)")
  50. )
  51.  
  52. (eval-when (compile load eval)
  53. (defclass user-vector-class-mixin () ()
  54.   (:documentation
  55.     "Use this mixin for metaclasses whose instances are USER-INSTANCES
  56.      instantiated as simple-vectors.  This saves space over the standard
  57.      instances used by standard-class, at the cost of losing the ability to
  58.      redefine the slots in a class and still have old instances updated correctly."))
  59.  
  60. (defclass user-vector-class (user-vector-class-mixin standard-class) ()
  61.   (:documentation
  62.     "A metaclass whose instances are USER-INSTANCES instantiated as simple-vectors.
  63.      This saves space over the standard instances used by standard-class, at the
  64.      cost of losing the ability to redefine the slots in a class and still have old
  65.      instances updated correctly."))
  66.  
  67. (defmethod validate-superclass ((class user-vector-class-mixin)
  68.                                 (new-super T))
  69.   (or (typep new-super 'user-vector-class-mixin)
  70.       (eq new-super (find-class 'standard-object))))
  71.  
  72. (defclass user-vector-object (standard-object) ()
  73.   (:metaclass user-vector-class))
  74. )
  75.  
  76. ;;;
  77. ;;;
  78. ;;; Instance allocation stuff.
  79. ;;;
  80.  
  81. (defmacro user-vector-instance-p (object)
  82.   (once-only (object)
  83.     `(the boolean
  84.           (and (simple-vector-p ,object)
  85.                (plusp (length (the simple-vector ,object)))
  86.                (wrapper-p (%svref ,object 0))))))
  87.  
  88. (defmacro user-vector-instance-wrapper (object)
  89.   `(%svref ,object 0))
  90.  
  91. (defsetf user-vector-instance-wrapper (object) (new-value)
  92.   `(setf (%svref ,object 0) ,new-value))
  93.  
  94. (defmacro user-vector-instance-slots (instance)
  95.   ;; The slots vector of user-vector instances is the instance itself.
  96.   instance)
  97.  
  98. (defmacro set-user-vector-instance-slots (instance new-value)
  99.   `(progn
  100.      (warn "Attempt to set user-vector-instance-slots of ~S to ~S"
  101.            ,instance ,new-value)
  102.      ,new-value))
  103.  
  104. (defun user-instance-p (x)
  105.   "Is X a user instance, specifically a user-vector-instance?"
  106.   (user-vector-instance-p x))
  107.  
  108. (defun user-instance-slots (x)
  109.   "Return the slots of this user-vector-instance."
  110.   (user-vector-instance-slots x))
  111.  
  112. (defun user-instance-wrapper (x)
  113.   "Return the wrapper of this user-vector-instance."
  114.   (user-vector-instance-wrapper x))
  115.  
  116. (defun set-user-instance-wrapper (x new)
  117.   (setf (user-vector-instance-wrapper x) new))
  118.  
  119. (defmacro get-user-instance-p (x)
  120.   `(user-vector-instance-p ,x))
  121.  
  122. (defmacro get-user-instance-wrapper (x)
  123.   `(user-vector-instance-wrapper ,x))
  124.  
  125. (defmacro get-user-instance-slots (x)
  126.   `(user-vector-instance-slots ,x))
  127.  
  128. (eval-when (eval #+cmu load)
  129.   (force-compile 'user-instance-p)
  130.   (force-compile 'user-instance-slots)
  131.   (force-compile 'user-instance-wrapper)
  132.   (force-compile 'set-user-instance-wrapper))
  133.  
  134.  
  135. ;;;
  136. ;;; Methods needed for user-vector-class-mixin.
  137. ;;;
  138.  
  139. (defconstant *not-a-slot* (gensym "NOT-A-SLOT"))
  140.  
  141. (defmethod allocate-instance ((class user-vector-class-mixin) &rest initargs)
  142.   (declare (ignore initargs))
  143.   (unless (class-finalized-p class) (finalize-inheritance class))
  144.   (let* ((class-wrapper (class-wrapper class))
  145.          (copy-instance (wrapper-allocate-static-slot-storage-copy
  146.                            class-wrapper))
  147.          (instance      (copy-simple-vector copy-instance)))
  148.     (declare (type simple-vector copy-instance instance))
  149.     (setf (user-vector-instance-wrapper instance) class-wrapper)
  150.     instance))
  151.  
  152. (defmethod make-instances-obsolete ((class user-vector-class-mixin))
  153.   "The slots of user-vector-instances are stored in the instance vector
  154.    themselves (a simple-vector), so old instances cannot be updated properly."
  155.   (setf (slot-value class 'prototype) NIL)
  156.   (warn "Obsoleting user-vector class ~A, all current instances will be invalid..."
  157.         class))
  158.  
  159. (defmethod compute-layout :around ((class user-vector-class-mixin)
  160.                                     cpl instance-eslotds)
  161.   ;; First element of user-vector-instance is actually its wrapper.
  162.   (declare (ignore cpl instance-eslotds))
  163.   (cons *not-a-slot* (call-next-method)))
  164.  
  165. (defmethod compute-instance-layout :around ((class user-vector-class-mixin)
  166.                                             instance-eslotds)
  167.   ;; First element of user-vector-instance is actually its wrapper.
  168.   (declare (ignore instance-eslotds))
  169.   (cons *not-a-slot* (call-next-method)))
  170.  
  171. (defmethod wrapper-fetcher ((class user-vector-class-mixin))
  172.   'user-vector-instance-wrapper)
  173.  
  174. (defmethod slots-fetcher ((class user-vector-class-mixin))
  175.   'user-vector-instance-slots)
  176.  
  177. (defmethod raw-instance-allocator ((class user-vector-class-mixin))
  178.   'allocate-user-vector-instance)
  179.  
  180.  
  181. ;;; Inform PCL that it is still safe to use its standard slot-value
  182. ;;; optimizations with user-vector-class-mixin's slot-value-using-class
  183. ;;; methods:
  184.  
  185. (pushnew
  186.   '(user-vector-class-mixin standard-object standard-effective-slot-definition)
  187.    *safe-slot-value-using-class-specializers*)
  188.  
  189. (pushnew
  190.   '(T user-vector-class-mixin standard-object standard-effective-slot-definition)
  191.    *safe-set-slot-value-using-class-specializers*)
  192.  
  193. (pushnew
  194.   '(user-vector-class-mixin standard-object standard-effective-slot-definition)
  195.   *safe-slot-boundp-using-class-specializers*)
  196.  
  197. (defmethod slot-value-using-class
  198.   ((class user-vector-class-mixin)
  199.    (object standard-object)
  200.    (slotd standard-effective-slot-definition))
  201.   (let* ((location (slot-definition-location slotd))
  202.      (value
  203.            (typecase location
  204.           (fixnum
  205.                 (%svref (user-vector-instance-slots object) location))
  206.           (cons
  207.             (cdr location))
  208.           (t
  209.            (error
  210.                  "The slot ~s has neither :instance nor :class allocation, ~@
  211.                               so it can't be read by the default ~s method."
  212.           slotd 'slot-value-using-class)))))
  213.     (if (eq value *slot-unbound*)
  214.     (slot-unbound class object (slot-definition-name slotd))
  215.     value)))
  216.  
  217. (defmethod (setf slot-value-using-class)
  218.        (new-value (class user-vector-class-mixin)
  219.                       (object standard-object)
  220.               (slotd standard-effective-slot-definition))
  221.   (let ((location (slot-definition-location slotd)))
  222.     (typecase location
  223.       (fixnum
  224.         (setf (%svref (user-vector-instance-slots object) location) new-value))
  225.       (cons
  226.         (setf (cdr location) new-value))
  227.       (t
  228.        (error "The slot ~s has neither :instance nor :class allocation, ~@
  229.                            so it can't be written by the default ~s method."
  230.           slotd '(setf slot-value-using-class))))))
  231.  
  232. (defmethod slot-boundp-using-class
  233.   ((class user-vector-class-mixin)
  234.    (object standard-object)
  235.    (slotd standard-effective-slot-definition))
  236.   (let* ((location (slot-definition-location slotd))
  237.      (value
  238.            (typecase location
  239.          (fixnum
  240.                (%svref (user-vector-instance-slots object) location))
  241.          (cons
  242.            (cdr location))
  243.          (t
  244.            (error
  245.                  "The slot ~s has neither :instance nor :class allocation, ~@
  246.                               so it can't be read by the default ~s method."
  247.          slotd 'slot-boundp-using-class)))))
  248.     (not (eq value *slot-unbound*))))
  249.  
  250.  
  251.  
  252. ;;;
  253. ;;; The following functions and methods are not strictly necessary for
  254. ;;; user-vector-instances, but do speed things up a bit.
  255. ;;;
  256.  
  257. (defmethod make-optimized-reader-method-function
  258.            ((class user-vector-class-mixin)
  259.             generic-function
  260.             reader-method-prototype
  261.             slot-name)
  262.   (declare (ignore generic-function reader-method-prototype))
  263.   (make-user-vector-instance-reader-method-function slot-name))
  264.  
  265. (defmethod make-optimized-writer-method-function
  266.            ((class user-vector-class-mixin)
  267.             generic-function
  268.             reader-method-prototype
  269.             slot-name)
  270.   (declare (ignore generic-function reader-method-prototype))
  271.   (make-user-vector-instance-writer-method-function slot-name))
  272.  
  273. (defmethod make-optimized-method-function
  274.            ((class user-vector-class-mixin)
  275.             generic-function
  276.             boundp-method-prototype
  277.             slot-name)
  278.   (declare (ignore generic-function boundp-method-prototype))
  279.   (make-user-vector-instance-boundp-method-function slot-name))
  280.  
  281. (defun make-user-vector-instance-reader-method-function (slot-name)
  282.   (declare #.*optimize-speed*)
  283.   #'(lambda (instance)
  284.       (user-instance-slot-value instance slot-name)))
  285.  
  286. (defun make-user-vector-instance-writer-method-function (slot-name)
  287.   (declare #.*optimize-speed*)
  288.   #'(lambda (nv instance)
  289.       (setf (user-instance-slot-value instance slot-name) nv)))
  290.  
  291. (defun make-user-vector-instance-boundp-method-function (slot-name)
  292.   (declare #.*optimize-speed*)
  293.   #'(lambda (instance)
  294.       (user-instance-slot-boundp instance slot-name)))
  295.  
  296.  
  297. (defun make-optimized-user-reader-method-function (slot-name index)
  298.   (declare #.*optimize-speed*)
  299.   (progn slot-name)
  300.   #'(lambda (instance)
  301.       (let ((value (%svref (user-vector-instance-slots instance) index)))
  302.         (if (eq value *slot-unbound*)
  303.             (slot-unbound (class-of instance) instance slot-name)
  304.             value))))
  305.  
  306. (defun make-optimized-user-writer-method-function (index)
  307.   (declare #.*optimize-speed*)
  308.   #'(lambda (nv instance)
  309.       (setf (%svref (user-vector-instance-slots instance) index) nv)))
  310.  
  311. (defun make-optimized-user-boundp-method-function (index)
  312.   (declare #.*optimize-speed*)
  313.   #'(lambda (instance)
  314.       (not (eq (%svref (user-vector-instance-slots instance) index)
  315.                *slot-unbound*))))
  316.  
  317.  
  318.  
  319. (defmacro with-user-instance-slots (slot-entries instance-form &body body)
  320.   "Optimized version of With-Slots that assumes that the instance-form
  321.    evaluates to a user-vector-instance.  The result is undefined if it does not.
  322.    With-user-vector-instance-slots is faster than With-Slots because it factors
  323.    out functions common to all slot accesses on the instance.  It has two
  324.    extensions to With-Slots: (1) the second value of slot-entries are
  325.    evaluated as forms rather than considered to be hard slot-names, allowing
  326.    access of variable slot-names.  (2) if a :variable-instance keyword is
  327.    the first part of the body, then the instance-form is treated as a variable
  328.    form, which is always expected to return an instance of the same class.
  329.    The value of the keyword must be an instance that is the same class as
  330.    instance-form will always return."
  331.   (build-with-optimized-slots-form slot-entries instance-form body 'user-instance))
  332.  
  333.  
  334.  
  335. ;;;
  336. ;;;  Lisp and CLOS print compatability functions:
  337. ;;;
  338. ;;;  This gets really ugly because most lisps don't use PRINT-OBJECT
  339. ;;;  for the printed representation of their objects like they're supposed
  340. ;;;  to.  (And if the lisp did, it wouldn't be using PCL.).  And since
  341. ;;;  user-vector-instances are implemented as simple-vectors, the only
  342. ;;;  way to get their printed representations to look right is to make
  343. ;;;  PRINT-OBJECT object to work.
  344. ;;;    We therefore have to patch the standard lisp printing functions.
  345. ;;;  If all goes well, then everything is honky-dory.  If it doesn't, then
  346. ;;;  debugging can get pretty messy since we were screwing with the standard
  347. ;;;  printing functions.  Things should work, but if they don't, then calling
  348. ;;;  RESTORE-LISP-PRINTERS will get things back to normal.
  349.  
  350. (defvar *old-write* NIL)
  351. (defvar *old-princ* NIL)
  352. (defvar *old-prin1* NIL)
  353. (defvar *old-print* NIL)
  354.  
  355. ;; Structure dummy-print-instance is a structure whose sole purpose
  356. ;; in life is to act as a placeholder to allow the print-object of 
  357. ;; user-vector-class objects to be printed.
  358.  
  359. (defstruct (dummy-print-instance
  360.               (:print-function print-dummy-print-instance))
  361.   (print-object-string nil))
  362.  
  363. (declaim (type list *dummy-print-instance-garbage*))
  364. (defvar      *dummy-print-instance-garbage* NIL)
  365. (defconstant *dummy-print-instance-garbage-limit* 100)
  366.  
  367. (defmacro pure-array-p (x &optional (test-user-vector-instance-p T))
  368.   "Returns whether item is a 'pure' array -- i.e. not a string, and
  369.    not something holding a CLOS instance."
  370.   (once-only (x)
  371.     `(the boolean
  372.           (locally (declare (inline arrayp stringp typep))
  373.             (and (arrayp ,x)
  374.                  (not (stringp ,x))
  375.                  #-(or cmu (and lucid pcl))
  376.                  (not (typep ,x 'structure))
  377.                  ,@(when test-user-vector-instance-p
  378.                      `((not (user-vector-instance-p ,x))))
  379.                  #-(or cmu (and lucid pcl))
  380.                  (not (typep ,x 'standard-object)))))))
  381.  
  382. (defun copy-any-array (old-array &rest keys-passed &key key dimensions)
  383.   ;; Returns a copy of old-array.  If :key is provided, then the
  384.   ;; elements of the new-array are the result of key applied to
  385.   ;; old-array's elements.  If :dimensions is provided, and it is
  386.   ;; different than old-array's dimensions, then the new-array is created
  387.   ;; with those dimensions, and everything that can be copied from
  388.   ;; old-array is copied into it.  It is an error if the rank of
  389.   ;; the array specified by dimensionss is different than that of the
  390.   ;; old-array.
  391.   (declare (type array              old-array)
  392.            (type (or function null) key)
  393.            (type list               dimensions keys-passed))
  394.   (cond
  395.     ((simple-vector-p old-array)
  396.      (apply #'copy-array-contents
  397.             old-array
  398.             (make-array (the index
  399.                              (if dimensions
  400.                                  (car dimensions)
  401.                                (length (the simple-vector old-array)))))
  402.             keys-passed))
  403.     ((vectorp old-array)
  404.      (apply #'copy-array-contents
  405.             old-array
  406.             (make-array (the index
  407.                              (if dimensions
  408.                                  (car dimensions)
  409.                                (length (the vector old-array))))
  410.                         :element-type (array-element-type old-array)
  411.                         :adjustable   (adjustable-array-p old-array))
  412.             keys-passed))
  413.     ((arrayp old-array)
  414.      (let* ((old-dimensions (array-dimensions   old-array))
  415.             (new-dimensions (or dimensions old-dimensions))
  416.             (element-type   (array-element-type old-array))
  417.             (new-array
  418.               (make-array new-dimensions
  419.                           :element-type element-type
  420.                           :adjustable   (adjustable-array-p old-array))))
  421.        (declare (type list  old-dimensions new-dimensions)
  422.                 (type array new-array))
  423.        (if (or (null dimensions) (equal new-dimensions old-dimensions))
  424.            (let* ((displaced-old-array
  425.                     (make-array (array-total-size old-array)
  426.                       :element-type element-type
  427.                       :displaced-to old-array))
  428.                   (displaced-new-array
  429.                     (make-array (array-total-size new-array)
  430.                       :element-type element-type
  431.                       :displaced-to new-array)))
  432.              (declare (type array displaced-old-array displaced-new-array))
  433.              (copy-array-contents displaced-old-array
  434.                                   displaced-new-array
  435.                                   :key key))
  436.          (let ((first-dimension
  437.                   (min (the index (car new-dimensions))
  438.                        (the index (car old-dimensions)))))
  439.             (declare (type index first-dimension))
  440.             (walk-dimensions
  441.               (mapcar #'min (cdr new-dimensions) (cdr old-dimensions))
  442.               #'(lambda (post-indices)
  443.                  (copy-array-contents old-array new-array
  444.                                       :key key
  445.                                       :length first-dimension
  446.                                       :post-indices post-indices)))))
  447.        new-array))))
  448.  
  449. (defun copy-array-contents
  450.        (old-array new-array &key key length post-indices &allow-other-keys)
  451.   ;; Copies the contents of old-array into new-array, using key if
  452.   ;; supplied.  Only the first :length items are copied (defaulting
  453.   ;; to the length of the old-array).  If :post-indices are passed, then
  454.   ;; they are used as "post" indices to an aref.
  455.   (macrolet
  456.    ((do-copy (aref old new key key-type len post-indices)
  457.      (let ((atype (if (eq aref #'svref) 'simple-vector 'array)))
  458.        `(dotimes (i (the index ,len))
  459.           (setf ,(if post-indices
  460.                      `(apply #'aref (the ,atype ,new) i ,post-indices)
  461.                     `(,aref (the ,atype ,new) i))
  462.                 ,(if key-type
  463.                      `(funcall
  464.                         (the ,key-type ,key)
  465.                         ,(if post-indices
  466.                              `(apply #'aref (the ,atype ,old)
  467.                                      i ,post-indices)
  468.                            `(,aref (the ,atype ,old) i)))
  469.                    (if post-indices
  470.                       `(apply #'aref (the ,atype ,old) i ,post-indices)
  471.                     `(,aref (the ,atype ,old) i)))))))
  472.      (expand-on-key (aref key old new len post-ind)
  473.        `(cond
  474.          ((null ,key)
  475.           (do-copy ,aref ,old ,new ,key NIL ,len ,post-ind))
  476.          ((compiled-function-p ,key)
  477.           (do-copy ,aref ,old ,new ,key compiled-function ,len ,post-ind))
  478.          (T
  479.           (do-copy ,aref ,old ,new ,key function ,len ,post-ind)))))
  480.     (if (simple-vector-p old-array)
  481.         (progn
  482.           (when post-indices
  483.             (error "Can't pass post-indices given to COPY-ARRAY-CONTENTS
  484.                     from simple-vector"))
  485.           
  486.           (unless length
  487.             (setf length (min (length (the simple-vector old-array))
  488.                               (length (the simple-vector new-array)))))
  489.           (expand-on-key svref key old-array new-array length NIL))
  490.        (progn
  491.          (unless length
  492.            (setf length (min (the index (car (array-dimensions old-array)))
  493.                              (the index (car (array-dimensions new-array))))))
  494.          (if post-indices
  495.              (expand-on-key #'aref key old-array new-array length post-indices)
  496.              (expand-on-key aref key old-array new-array length NIL)))))
  497.   new-array)
  498.  
  499. (declaim (ftype (function (list function) T) walk-dimensions))
  500. (defun walk-dimensions (dimensions fn)
  501.   (declare (type list     dimensions)
  502.            (type function fn))
  503.   ;; Given a list of dimensions (e.g. '(3 2 8)), this function walks
  504.   ;; through every possible combination from 0 to 1- each of those
  505.   ;; dimensions, and calling fn on each of them.
  506.   (let ((compiled-p (compiled-function-p fn)))
  507.     (labels
  508.       ((doit (dims apply-dims)
  509.          (declare (type list dims apply-dims))
  510.          (if (cdr dims)
  511.              (let ((last-dim  NIL)
  512.                    (dims-left NIL))
  513.                 (loop (when (null (cdr dims))
  514.                         (setf last-dim (car dims))
  515.                         (return))
  516.                       (if dims-left
  517.                           (nconc dims-left (list (car dims)))
  518.                         (setf dims-left (list (car dims))))
  519.                       (setf dims (cdr dims)))
  520.                  (dotimes (i (the index last-dim))
  521.                    (doit dims-left (cons i apply-dims))))
  522.            (if compiled-p 
  523.                (dotimes (i (the index (car dims)))
  524.                  (funcall (the compiled-function fn) (cons i apply-dims)))
  525.              (dotimes (i (the index (car dims)))
  526.                (funcall fn (cons i apply-dims)))))))
  527.       (doit dimensions NIL))))
  528.  
  529. (defmacro funcall-printer (applyer print-function object keys)
  530.   `(progn
  531.      (if (or (arrayp ,object) (consp ,object))
  532.          (multiple-value-bind (converted-item garbage)
  533.            (convert-user-vector-instances-to-dummy-print-instances ,object)
  534.            (,applyer (the compiled-function ,print-function)
  535.                      converted-item ,keys)
  536.            (deallocate-dummy-print-instances garbage))
  537.        (,applyer (the compiled-function ,print-function)
  538.                 ,object ,keys))
  539.      ,object))
  540.  
  541. (defun print-dummy-print-instance (instance stream depth)
  542.   (declare (ignore depth))
  543.   (let ((*print-pretty* NIL))
  544.     (funcall (the compiled-function *old-princ*)
  545.              (dummy-print-instance-print-object-string instance)
  546.              stream)))
  547.  
  548. (defun allocate-dummy-print-instance (print-object-string)
  549.   (if *dummy-print-instance-garbage*
  550.       (let ((instance (pop *dummy-print-instance-garbage*)))
  551.         (setf (dummy-print-instance-print-object-string instance)
  552.               print-object-string)
  553.         instance)
  554.     (make-dummy-print-instance :print-object-string print-object-string)))
  555.  
  556. (defun dummy-print-instance-of (user-vector-instance)
  557.   (allocate-dummy-print-instance 
  558.     (with-output-to-string (str)
  559.       (print-object user-vector-instance str))))
  560.  
  561. (defun deallocate-dummy-print-instances (dummies)
  562.   (let ((count (length *dummy-print-instance-garbage*)))
  563.     (declare (type index count))
  564.     (dolist (dummy dummies)
  565.       (when (> count *dummy-print-instance-garbage-limit*)
  566.         (return))
  567.       (push dummy *dummy-print-instance-garbage*)
  568.       (setf count (the index (1+ count))))))
  569.    
  570. (defun convert-user-vector-instances-to-dummy-print-instances (item)
  571.   (let ((print-length
  572.           (or *print-length* 1000))
  573.         (print-level
  574.           (or *print-level* 1000))
  575.         (dummy-print-instances-used NIL))
  576.     (declare (fixnum print-length print-level))
  577.     (labels
  578.       ((doit (item level length)
  579.          (declare (fixnum level length))
  580.          (labels
  581.            ((user-vector-instance-visible-within-p (item level length)
  582.               (declare (fixnum level length))
  583.               (cond
  584.                 ((>= length print-length) NIL)
  585.                 ((> level print-level) NIL)
  586.                 ((= level print-level) (user-vector-instance-p item))
  587.                 (T (cond
  588.                     ((user-vector-instance-p item) T)
  589.                     ((consp item)
  590.                      (or (user-vector-instance-visible-within-p
  591.                            (car item) (the fixnum (1+ level)) 0)
  592.                          (user-vector-instance-visible-within-p
  593.                            (cdr item) level (the fixnum (1+ length)))))
  594.                     ((and *print-array* (pure-array-p item))
  595.                      (let ((next-level (the fixnum (1+ level))))
  596.                        (declare (fixnum next-level))
  597.                        (dotimes (i (1- (length (the array item))) NIL)
  598.                          (unless (< i print-length)
  599.                            (return NIL))
  600.                          (if (user-vector-instance-visible-within-p
  601.                                (aref item i) next-level 0)
  602.                              (return T))))))))))
  603.             ;; doit body
  604.             (cond
  605.               ((user-vector-instance-p item)
  606.                (let ((dummy (dummy-print-instance-of item)))
  607.                  (push dummy dummy-print-instances-used)
  608.                  dummy))
  609.               ((consp item)
  610.                (if (user-vector-instance-visible-within-p item level length)
  611.                    (cons (doit (car item) (the fixnum (1+ level)) length)
  612.                          (doit (cdr item) level (the fixnum (1+ length))))
  613.                  item))
  614.               ((and *print-array* (pure-array-p item NIL))
  615.                (if (user-vector-instance-visible-within-p item level length)
  616.                    (copy-any-array
  617.                      item
  618.                      :key
  619.                      #'(lambda (item)
  620.                          (if (user-vector-instance-p item)
  621.                              (let ((dummy (dummy-print-instance-of item)))
  622.                                (push dummy dummy-print-instances-used)
  623.                                dummy)
  624.                            item))
  625.                      :dimensions
  626.                        (mapcar #'1+ (array-dimensions item)))
  627.                     item))
  628.               (T item)))))
  629.  
  630.       ;; convert-user-vector-instances-to-dummy-print-instances body
  631.  
  632.       (let ((converted (doit item 0 0)))
  633.         (values converted dummy-print-instances-used)))))
  634.  
  635. (force-compile 'convert-user-vector-instances-to-dummy-print-instances)
  636.  
  637. (unless *old-write* (setf *old-write* (symbol-function 'write)))
  638. (defun new-write (object &rest keys-passed)
  639.   (declare (list keys-passed))
  640.   (funcall-printer apply *old-write* object keys-passed))
  641. (force-compile 'write)
  642. (setf (symbol-function 'write) (symbol-function 'new-write))
  643.  
  644. (unless *old-princ* (setf *old-princ* (symbol-function 'princ)))
  645. (defun princ (object &optional stream)
  646.   (funcall-printer funcall *old-princ* object stream))
  647. (force-compile 'princ)
  648.  
  649. (unless *old-prin1* (setf *old-prin1* (symbol-function 'prin1)))
  650. (defun prin1 (object &optional stream)
  651.   (funcall-printer funcall *old-prin1* object stream))
  652. (force-compile 'prin1)
  653.  
  654. (unless *old-print* (setf *old-print* (symbol-function 'print)))
  655. (defun print (object &optional stream)
  656.   (funcall-printer funcall *old-print* object stream))
  657. (force-compile 'print)
  658.  
  659. (defun new-write-to-string (object &rest keys-passed)
  660.   (declare (list keys-passed))
  661.   (with-output-to-string (string-stream)
  662.     (apply #'write object :stream string-stream keys-passed)))
  663. (force-compile 'write-to-string)
  664. (setf (symbol-function 'write-to-string)
  665.       (symbol-function 'new-write-to-string))
  666.  
  667. (defun princ-to-string (object)
  668.   (with-output-to-string (string-stream)
  669.     (funcall-printer funcall *old-princ* object string-stream)
  670.     string-stream))
  671. (force-compile 'princ-to-string)
  672.  
  673. (defun prin1-to-string (object)
  674.   (with-output-to-string (string-stream)
  675.     (funcall-printer funcall *old-prin1* object string-stream)
  676.     string-stream))
  677. (force-compile 'prin1-to-string)
  678.  
  679. (defun restore-lisp-printers ()
  680.   (setf (symbol-function 'write) *old-write*)
  681.   (setf (symbol-function 'princ) *old-princ*)
  682.   (setf (symbol-function 'prin1) *old-prin1*)
  683.   (setf (symbol-function 'print) *old-print*))
  684.  
  685.